home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / compiler / common / line-numbers.lisp < prev    next >
Lisp/Scheme  |  1992-09-10  |  3KB  |  100 lines
  1. ;;; (C) Copyright 1990-1992 by Wade L. Hennessey. All rights reserved.
  2.  
  3. #|
  4. 1) make 2 lib switch - one for lsyms, one for just regular syms
  5. fix data emit?      
  6. test new eql on other numb and mixed symbol compares
  7.  
  8. fix spec binds/unbind/unwind
  9.       case UW_SPECBIND:
  10.     LDREF(uw_top->name,SYMBOL,value) = uw_top->value;
  11.     POP_UW_POINT;
  12.     break;
  13.  
  14. Zap update_var and friends?
  15.  
  16. ADD INLINEs back to symbol stuff
  17. FIX EQ
  18.  
  19. ;;; ******* Line symbol specific versions of symbol primitives.
  20. ;;; HEY! This one doesn't indirect through the link field.
  21. (defprimitive %boundp ((sym symbol) => (flag if-test))
  22.   (emit-c "(LDREF(~A,SYMBOL,value) != UBV_MARKER)" sym))
  23.  
  24. ;;; HEY! Check that the fcell really contains a function, or
  25. ;;; rely on setters to always check this?
  26. (defprimitive %fboundp ((sym symbol) => (flag if-test))
  27.   (emit-c "(SYMREF(~A,function) != (LP) LREF(ubf_procedure))" sym))
  28.  
  29. (defprimitive %makunbound ((sym symbol) => ())
  30.   (emit-c "SYMREF(~A,value) = UBV_MARKER" sym))
  31.  
  32. (defprimitive %symref ((sym t) (i int) => (v t))
  33.   (emit-c "(LP) DEREF(((LP) LDREF(~A,SYMBOL,self_link)) + ~A * 4)" sym i))
  34.  
  35. (defprimitive %symdef ((sym t) (i int) (y t) => ())
  36.   (emit-c "(LP) (DEREF(((LP) LDREF(~A,SYMBOL,self_link)) + ~A * 4) = (LD) ~A)"
  37.       sym i y))
  38.  
  39. add this to c_eql
  40. if ((x_tag == 3) && (y_tag == 3)) {
  41. return((LDREF(x,SYMBOL,self_link) == LDREF(y,SYMBOL,self_link))
  42. ? T : NIL);
  43. }
  44. |#
  45.  
  46. ;;; Skip whitespace and comments so line number of start of form is correct.
  47. (defun skip-to-next-form (stream)
  48.   (skip-to-next-form-1 stream (read-char stream nil stream)))
  49.  
  50. (defun skip-to-next-form-1 (stream char)
  51.   (cond ((= (get-char-syntax *readtable* char) whitespace)
  52.      (skip-to-next-form-1 stream (read-char stream nil stream)))
  53.     ((char= char #\;)
  54.      (loop for ch = (read-char stream nil #\Newline t)
  55.            until (char= ch #\Newline))
  56.      (skip-to-next-form-1 stream (read-char stream nil stream)))
  57.     ((eq stream char) stream)
  58.     (t (unread-char char stream))))
  59.  
  60. (defun char-macro-open-paren-with-lines (stream char)
  61.   (declare (ignore char))
  62.   (if (line-number-stream-p stream)
  63.       (let ((*open-paren-count* (+ *open-paren-count* 1)))
  64.     (skip-to-next-form stream)
  65.     (let ((line (line-number-stream-line stream))
  66.           (l (read-list-with-lines stream)))
  67.       (setf (gethash l *source-table*) line)
  68.     l))
  69.       (char-macro-open-paren stream char)))
  70.  
  71. (defun read-list-with-lines (stream)
  72.   (skip-to-next-form stream)
  73.   (let* ((line (line-number-stream-line stream))
  74.      (x (read/4 stream t nil t))
  75.      (item (if (symbolp x) (make-line-symbol x line) x)))    
  76.     (select item
  77.       (*close-paren-marker* nil)
  78.       (*dot-marker*
  79.        (let ((cdr (read/4 stream t nil t))
  80.          (close (read/4 stream t nil t)))
  81.      (unless (eq close *close-paren-marker*)
  82.        (error "A closing parenthesis is missing after a dot"))
  83.      cdr))
  84.       (t (let ((l (cons item (read-list-with-lines stream))))
  85.        (if (or (consp item) (fixnump item) (characterp item))
  86.            (setf (gethash l *source-table*) line)
  87.            (setf (gethash item *source-table*) line))
  88.        l)))))
  89.  
  90. (defun make-line-number-readtable ()
  91.   (let ((rt (make-default-readtable)))
  92.     (set-macro-character #\( #'char-macro-open-paren-with-lines nil rt)
  93.     rt))
  94.  
  95. (defun source-line (form)
  96.   (if (line-symbol-p form)
  97.       (line-symbol-line form)
  98.       (gethash form *source-table*)))
  99.  
  100.